home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Examples / MapMaker.p < prev    next >
Text File  |  1989-07-02  |  7KB  |  287 lines
  1. Program MapMaker;
  2.  
  3. {$I ":Include/Exec.i"}
  4. {$I ":Include/Ports.i"}
  5. {$I ":Include/Graphics.i"}
  6. {$I ":Include/Intuition.i"}
  7. {$I ":Include/DOS.i" solely for the DateStamp thing }
  8.  
  9. {
  10.     This program just draws a blocky map from straight overhead,
  11. then repeatedly splits each block into four parts and adjusts the
  12. elevation of each of the parts until it gets down to one pixel per
  13. block.  It ends up looking something like a terrain map.  It's kind
  14. of a fractal thing, but not too much.  Some program a long time ago
  15. inspired this, but I apologize for forgetting which one.  As I
  16. recall, that program was derived from Chris Gray's sc.
  17.     Once upon a time I was thinking about writing an overblown
  18. strategic conquest game, and this was the first stab at a map
  19. maker.  The maps it produces look nifty, but have no sense of
  20. geology so they're really not too useful for a game.
  21.     When the map is finished, press the left button inside the
  22. window somewhere and the program will go away.
  23. }
  24.  
  25. const
  26.     MinX = 0;
  27.     MaxX = 320;
  28.     MinY = 0;
  29.     MaxY = 200;
  30.  
  31. type
  32.     MapArray = array [MinX .. MaxX - 1, MinY .. MaxY - 1] of Byte;
  33.  
  34. VAR
  35.     average,x,y,
  36.     nextx,nexty,count,
  37.     skip,level      : Short;
  38.     rp            : RastPortPtr;
  39.     vp            : Address;
  40.     s             : ScreenPtr;
  41.     w             : WindowPtr;
  42.     Seed      : Integer;
  43.     m             : MessagePtr;
  44.     Map           : MapArray;
  45.     Quit      : Boolean;
  46.  
  47. Function RangeRandom (MaxValue : Integer): Integer;
  48. begin
  49.     Inc(Seed);
  50.     Seed := (Seed * 171) MOD 30269;
  51.     RangeRandom := Seed mod (Succ(MaxValue));
  52. end;
  53.  
  54. Procedure SetSeed;
  55. var
  56.     time : DateStampRec;
  57. begin
  58.     DateStamp(time);
  59.     with time do
  60.     Seed := (dsDays + dsMinute + dsTick) and $7FFF;
  61. end;
  62.  
  63. Function FixX(x : short): short;
  64. begin
  65.     if x < 0 then
  66.     FixX := x + MaxX
  67.     else
  68.     FixX := x mod MaxX;
  69. end;
  70.  
  71. Function FixY(y : short) : short;
  72. begin
  73.     if x < 0 then
  74.     FixY := y + MaxY
  75.     else
  76.     FixY := y mod MaxY;
  77. end;
  78.  
  79. Procedure DrawMap;
  80. begin
  81.     if skip = 1 then begin
  82.     for x := MinX to MaxX - 1 do begin
  83.         for y := MinY to MaxY - 1 DO begin
  84.         if Map[x,y] < 100 then begin
  85.             SetAPen(rp, 0);
  86.             WritePixel(rp, x, y)
  87.         end else begin
  88.             average := (Map[x,y] - 100) DIV 6 + 1;
  89.             if average > 15 then
  90.             average := 15;
  91.             SetAPen(rp, average);
  92.             WritePixel(rp, x, y)
  93.         end
  94.         end
  95.     end
  96.    end else begin
  97.     for x := MinX to MaxX - 1 by skip do begin
  98.         for y := MinY to MaxY - 1 by skip do begin
  99.         if Map[x,y] < 100 then begin
  100.             SetAPen(rp, 0);
  101.             RectFill(rp,x,y,x + skip - 1,y + skip - 1)
  102.         end else begin
  103.             average := (Map[x,y] - 100) DIV 6 + 1;
  104.             if average > 15 then
  105.             average := 15;
  106.             SetAPen(rp,average);
  107.             RectFill(rp,x,y,x + skip - 1,y + skip - 1);
  108.         end;
  109.         end;
  110.     end;
  111.     end;
  112. end;
  113.  
  114. Function OpenTheScreen() : Boolean;
  115. var
  116.     ns : NewScreenPtr;
  117. begin
  118.     new(ns);
  119.     with ns^ do begin
  120.     LeftEdge := 0;
  121.     TopEdge  := 0;
  122.     Width    := 320;
  123.     Height   := 200;
  124.     Depth    := 4;
  125.     DetailPen := 3;
  126.     BlockPen  := 2;
  127.     ViewModes := 0;
  128.     SType     := CUSTOMSCREEN_f;
  129.     Font      := nil;
  130.     DefaultTitle := nil;
  131.     Gadgets   := nil;
  132.     CustomBitMap := nil;
  133.     end;
  134.  
  135.     s := OpenScreen(ns);
  136.     dispose(ns);
  137.     OpenTheScreen := s <> nil;
  138. end;
  139.  
  140. Function OpenTheWindow() : Boolean;
  141. var
  142.     nw : NewWindowPtr;
  143. begin
  144.     new(nw);
  145.     with nw^ do begin
  146.     LeftEdge := MinX;
  147.     TopEdge := MinY;
  148.     Width := MaxX;
  149.     Height := MaxY;
  150.  
  151.     DetailPen := -1;
  152.     BlockPen  := -1;
  153.     IDCMPFlags := MOUSEBUTTONS_f;
  154.     Flags := BORDERLESS_f + BACKDROP_f + SMART_REFRESH_f + ACTIVATE_f;
  155.     FirstGadget := nil;
  156.     CheckMark := nil;
  157.     Title := nil;
  158.     Screen := s;
  159.     BitMap := nil;
  160.     MinWidth := 50;
  161.     MaxWidth := -1;
  162.     MinHeight := 20;
  163.     MaxHeight := -1;
  164.     WType := CUSTOMSCREEN_f;
  165.     end;
  166.  
  167.     w := OpenWindow(nw);
  168.     dispose(nw);
  169.     OpenTheWindow := w <> nil;
  170. end;
  171.  
  172. Procedure MakeMap;
  173. begin
  174.  
  175.     rp:= w^.RPort;
  176.     vp:= ViewPortAddress(w);
  177.  
  178.     SetRGB4(vp, 0, 0, 0, 9); { Ocean Blue }
  179.     SetRGB4(vp, 1, 1, 1, 0);
  180.     SetRGB4(vp, 2, 0, 3, 0);
  181.     SetRGB4(vp, 3, 0, 4, 0); { Dark Green }
  182.     SetRGB4(vp, 4, 0, 5, 0);
  183.     SetRGB4(vp, 5, 1, 6, 0);
  184.     SetRGB4(vp, 6, 2, 8, 0); { Medium Green }
  185.     SetRGB4(vp, 7, 4, 10, 0);
  186.     SetRGB4(vp, 8, 6, 10, 0);
  187.     SetRGB4(vp, 9, 9, 9, 0); { Brown }
  188.     SetRGB4(vp, 10, 8, 8, 0);
  189.     SetRGB4(vp, 11, 7, 7, 0); { Dark Brown }
  190.     SetRGB4(vp, 12, 10, 10, 0); { Dark Grey }
  191.     SetRGB4(vp, 13, 10, 10, 10);
  192.     SetRGB4(vp, 14, 12, 12, 12);
  193.     SetRGB4(vp, 15, 14, 14, 15); { White }
  194.  
  195.     SetSeed;
  196.  
  197.     level := 7;
  198.     skip  := 16;
  199.     for y := MinY to MaxY - 1 by skip do
  200.     for x := MinX to MaxX - 1 by skip do
  201.         Map[x,y] := RangeRandom(220);
  202.  
  203.     DrawMap;
  204.  
  205.     for level := 2 to 5 do begin
  206.     skip := skip DIV 2;
  207.     for y := MinY to MaxY - 1 by skip do begin
  208.         if (y MOD (2*skip)) = 0 then
  209.         nexty := skip * 2
  210.         else
  211.         nexty:=skip;
  212.         for x := MinX to MaxX - 1 by skip do begin
  213.         if (x MOD (2*skip)) = 0 then
  214.             nextx := skip * 2
  215.         else
  216.             nextx := skip;
  217.         if (nextx = skip * 2) AND (nexty = skip * 2) then begin
  218.             average := Map[x,y] * 5;
  219.             count := 9;
  220.         end else begin
  221.             average := 0;
  222.             count := 4;
  223.         end;
  224.         if (nextx = skip * 2) then begin
  225.             average := average + Map[x,FixY(y - skip)];
  226.             average := average + Map[x,FixY(y + nexty)];
  227.             count := count + 2;
  228.         end;
  229.         if (nexty = skip * 2) then begin
  230.             average := average + Map[FixX(x - skip),y];
  231.             average := average + Map[FixX(x + nextx),y];
  232.             count := count + 2;
  233.         end;
  234.         average := average + Map[FixX(x-skip),FixY(y-skip)]
  235.                    + Map[FixX(x-nextx),FixY(y+nexty)]
  236.                    + Map[FixX(x+skip),FixY(y-skip)]
  237.                    + Map[FixX(x+nextx),FixY(y+nexty)];
  238.         average := (average DIV count) +
  239.                 (RangeRandom(4) - 2) * (9 - level);
  240.         case Average of
  241.           150..255 : Average := Average + 2;
  242.           100..149 : Inc(Average);
  243.         else
  244.             Average := Average - 3;
  245.         end;
  246.         if average < 0 then
  247.             average := 0;
  248.         if average > 220 then
  249.             average := 220;
  250.         Map[x,y] := average;
  251.         end;
  252.         m := GetMsg(w^.UserPort);
  253.         if m <> Nil then begin
  254.         Quit := True;
  255.         return;
  256.         end;
  257.     end;
  258.     DrawMap;
  259.     end;
  260. end;
  261.  
  262. begin
  263.     GfxBase := OpenLibrary("graphics.library", 0);
  264.     if GfxBase <> nil then begin
  265.     if OpenTheScreen() then begin
  266.         if OpenTheWindow() then begin
  267.         Quit := False;
  268.         ShowTitle(s, false);
  269.         MakeMap;
  270.         if not Quit then
  271.             m := WaitPort(w^.UserPort);
  272.         Forbid;
  273.         repeat
  274.             m := GetMsg(w^.UserPort);
  275.         until m = nil;
  276.         CloseWindow(w);
  277.         Permit;
  278.         end else
  279.         writeln('Could not open the window.');
  280.         CloseScreen(s);
  281.     end else
  282.         writeln('Could not open the screen.');
  283.     CloseLibrary(GfxBase);
  284.     end else
  285.     writeln('Could not open graphics.library');
  286. end.
  287.